' Copyrights  2012 - finaquant.com (Tunc A. Kutukcuoglu)
' Website: http://finaquant.com/
' Email: fqcontact@finaquant.com
'
' declare data type for all variables
Option Explicit
Option Base 1
'******************************************************************
' Increment multi-digit (multi-dimensional) counter especially for
' cartesian multiplication of attribute values
' Example:
'   Vcounter = [1  1  1] as initial state of 3-dim counter
'   VcounterLimits = [3 3 2] --> increment ([2 1 2]) = [2 2 1]
' - error if Vcounter or VcounterLimits is not a vector
' - IfLimitAchieved is false as long as counter hasn't reached counter_limits
' - error if sizes of Vcounter and VcounterLimits are not identical
' - error if any digit value in Vcounter is larger than the corresponding
'       value in VcounterLimits
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Sub FQ_increment_multidigit_counter(Vcounter() As Double, _
    VcounterLimits() As Double, IfLimitAchieved As Boolean)
Dim vlen As Long, i As Long, DigitCtr As Long, IfIncremented As Boolean
Dim IfEqual As Boolean
' Check if vector
If Not FQ_CheckIfVector(Vcounter) Then
    FQ_MessageBox ("Error in FQ_increment_multidigit_counter: Input argument Vcounter must be a vector!")
    Err.Raise (FQ_ErrorNum)
    Exit Sub
End If
If Not FQ_CheckIfVector(VcounterLimits) Then
    FQ_MessageBox ("Error in FQ_increment_multidigit_counter: Input argument VcounterLimits must be a vector!")
    Err.Raise (FQ_ErrorNum)
    Exit Sub
End If
' get vector length
vlen = UBound(Vcounter, 1)
If vlen <> UBound(VcounterLimits) Then
    FQ_MessageBox ("Error in FQ_increment_multidigit_counter: Sizes of input vectors Vcounter and VcounterLimits must be equal!")
    Err.Raise (FQ_ErrorNum)
    Exit Sub
End If
' check if any element of  Vcounter is larger than VcounterLimits'
For i = 1 To vlen
    If Vcounter(i) > VcounterLimits(i) Then
        FQ_MessageBox ("Error in FQ_increment_multidigit_counter: An element of Vcounter is larger than corresponding element in VcounterLimits!")
        Err.Raise (FQ_ErrorNum)
        Exit Sub
    End If
Next i

DigitCtr = vlen
IfIncremented = False

While DigitCtr > 0 And Not IfIncremented
    If VcounterLimits(DigitCtr) = 0 Then
        DigitCtr = DigitCtr - 1
    Else
        If Vcounter(DigitCtr) < VcounterLimits(DigitCtr) Then
            Vcounter(DigitCtr) = Vcounter(DigitCtr) + 1
            IfIncremented = True
        Else
            Vcounter(DigitCtr) = 1
            DigitCtr = DigitCtr - 1
        End If
    End If
Wend
' check if Vcounter = VcounterLimits
IfEqual = True
For i = 1 To vlen
    If Vcounter(i) <> VcounterLimits(i) Then
        IfEqual = False
        Exit For
    End If
Next i
If IfEqual Then
    IfLimitAchieved = True
    Else
    IfLimitAchieved = False
End If
End Sub
'******************************************************************
' Shifts all non-empty cells upwards so that there are no empty
' cells between non-empty ones.
' Vector Vctr returns the number of non-empty elements in each column
' - error if array is empty or not initialized, or not 2-dim
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Sub FQ_order_nonempty_elements(Arr As Variant, OrderedArr As Variant, _
        Vctr() As Double)
Dim i As Long, j As Long, nrow As Long, ncol As Long
Dim NonEmptyCtr As Double
On Error GoTo ErrorHandler
nrow = UBound(Arr, 1)
ncol = UBound(Arr, 2)
ReDim OrderedArr(1 To nrow, 1 To ncol)
ReDim Vctr(1 To ncol)
For j = 1 To ncol
    NonEmptyCtr = 0 ' # nonempty values in column
    For i = 1 To nrow
        If Not IsEmpty(Arr(i, j)) Then
            NonEmptyCtr = NonEmptyCtr + 1
            OrderedArr(NonEmptyCtr, j) = Arr(i, j)
        End If
    Next i
    Vctr(j) = NonEmptyCtr
Next j
Exit Sub
ErrorHandler:
FQ_MessageBox ("Error in FQ_variant_order_nonempty_elements!")
End Sub
'******************************************************************
' Function: Convert given sets of attribute values to attribute combinations
' Returns variant array for attribute combinations
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Function FQ_attribute_sets_to_combinations(AttributeSets As Variant, _
    CounterStop() As Double) As Variant()
Dim CounterState() As Double
Dim i As Long, CounterStopped As Boolean, AttributeCount As Integer
Dim str As String, CombinationCount As Long, j As Long

On Error GoTo EH1
' get number of attribute sets
AttributeCount = UBound(CounterStop)

' initiate counter vectors
ReDim CounterState(1 To AttributeCount)

CombinationCount = 1
For i = 1 To AttributeCount
    CounterState(i) = 1     ' initial state
    ' total number of attribute combinations
    CombinationCount = CombinationCount * CounterStop(i)
Next i

' initiate combination matrix
ReDim AttributeCombinations(1 To CombinationCount, 1 To AttributeCount)

' construct the first attribute combination
For i = 1 To AttributeCount
AttributeCombinations(1, i) = AttributeSets(1, i)
Next i

' construct all the rest of attribute combinations
i = 1
While Not CounterStopped
Call FQ_increment_multidigit_counter(CounterState, CounterStop, CounterStopped)
i = i + 1
For j = 1 To AttributeCount
AttributeCombinations(i, j) = AttributeSets(CounterState(j), j)
Next j
Wend

FQ_attribute_sets_to_combinations = AttributeCombinations
Exit Function
' Error handling
EH1:
FQ_MessageBox ("Error in FQ_attribute_sets_to_combinations: " & Err.Number & " - " & Err.Description)
Err.Raise (Err.Number)
End Function
'******************************************************************
' Generate test data by generating all possible combinations
' of given sets of attribute values
' - Reads attribute sets from excel, and writes the attributes combinations
' back to excel
' - TargetRange: Target worksheet range into which the generated test data
' (i.e. attribute combinations) is written. Only upper-left corner is relevant.
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Sub FQ_generate_test_data(AttributeDataRange As Range, TestDataRange As Range)
Dim AttributeData As Variant, AttributeSets As Variant
Dim OrderedArr As Variant, Vctr() As Double
Dim i As Long, j As Long, AttributeCombinations As Variant
Dim r1 As Range

On Error GoTo EH1
' read range with attribute values
AttributeData = FQ_range_to_variant(AttributeDataRange)

' Shift all non-empty cells upwards so that there are no empty
' cells between non-empty ones.
Call FQ_order_nonempty_elements(AttributeData, AttributeSets, Vctr)

' TEST
Set r1 = ThisWorkbook.Sheets("Sheet3").Range("E20")
Call FQ_variant_to_range(AttributeSets, r1)
Set r1 = ThisWorkbook.Sheets("Sheet3").Range("I20")
Call FQ_vector_to_range(Vctr, r1, MatrixAlignment.nVertical)
' test OK

' get all possible combinations of attribute values
AttributeCombinations = FQ_attribute_sets_to_combinations(AttributeSets, Vctr)

' write attribute combinations into worksheet range
Call FQ_variant_to_range(AttributeCombinations, TestDataRange)
Exit Sub
' Error handling
EH1:
FQ_MessageBox ("Error in FQ_generate_test_data: " & Err.Number & " - " & Err.Description)
Err.Raise (Err.Number)
End Sub
'******************************************************************
' Generate test data by generating all possible combinations
' of given sets of attribute values
' Worksheet makro
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Sub FQS_generate_test_data()
Dim AttributeData As Variant, AttributeSets As Variant
Dim OrderedArr As Variant, Vctr() As Double
Dim i As Long, j As Long, AttributeCombinations As Variant
Dim AttributeDataRange As Range, TestDataRange As Range

On Error GoTo EH1
' get attribute data from user
Set AttributeDataRange = Application.InputBox _
(Prompt:="Please select the worksheet range where you define the attribute value sets.", _
Title:="Attribute sets", Default:=Selection.Address, Type:=8)

' get output range
Set TestDataRange = Application.InputBox _
(Prompt:="Please select the upper-left corner of the worksheet range " & _
"where you want the have the test data as all possible combinations of attribute values.", _
Title:="Attribute sets", Default:=Selection.Address, Type:=8)

' read range with attribute values
AttributeData = FQ_range_to_variant(AttributeDataRange)

' Shift all non-empty cells upwards so that there are no empty
' cells between non-empty ones.
Call FQ_order_nonempty_elements(AttributeData, AttributeSets, Vctr)

' get all possible combinations of attribute values
AttributeCombinations = FQ_attribute_sets_to_combinations(AttributeSets, Vctr)

' write test data to output range
Call FQ_variant_to_range(AttributeCombinations, TestDataRange)
Exit Sub
' Error handling
EH1:
FQ_MessageBox ("Error in FQS_generate_test_data: " & Err.Number & " - " & Err.Description)
Err.Raise (Err.Number)
End Sub
'******************************************************************
' Generate test data by generating all possible combinations
' of given sets of attribute values; works with multiple range of data sets
' Worksheet makro
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Sub FQS_generate_test_data_multiple_range()
Dim AttributeData As Variant, AttributeSets As Variant
Dim OrderedArr As Variant, Vctr() As Double
Dim i As Long, AttributeCombinations() As Variant, AttributeCombinationsAll() As Variant
Dim AttributeDataRange As Range, TestDataRange As Range
Dim ReadMoreDataSets As Integer

ReadMoreDataSets = vbYes
i = 1

On Error GoTo EH1
While ReadMoreDataSets = vbYes
    ' get attribute data from user
    Set AttributeDataRange = Application.InputBox _
    (Prompt:="Please select the worksheet range where you define the attribute value sets.", _
    Title:="Attribute sets", Default:=Selection.Address, Type:=8)
    
    ' read range with attribute values
    AttributeData = FQ_range_to_variant(AttributeDataRange)
    
    ' Shift all non-empty cells upwards so that there are no empty
    ' cells between non-empty ones.
    Call FQ_order_nonempty_elements(AttributeData, AttributeSets, Vctr)
    
    ' get all possible combinations of attribute values
    AttributeCombinations = FQ_attribute_sets_to_combinations(AttributeSets, Vctr)
    AttributeCombinationsAll = FQ_matrix_append_var(AttributeCombinationsAll, _
        AttributeCombinations, nVertical)
    
    ' ask user if there is another data set
    ReadMoreDataSets = MsgBox(Prompt:="Is there another data set for attribute values?", _
        Buttons:=vbYesNo)
Wend

' get output range
Set TestDataRange = Application.InputBox _
(Prompt:="Please select the upper-left corner of the worksheet range " & _
"where you want the have the test data as all possible combinations of attribute values.", _
Title:="Attribute sets", Default:=Selection.Address, Type:=8)

' write test data to output range
Call FQ_variant_to_range(AttributeCombinationsAll, TestDataRange)
Exit Sub
' Error handling
EH1:
FQ_MessageBox ("Error in FQS_generate_test_data_multiple_range: " & Err.Number & " - " & Err.Description)
Err.Raise (Err.Number)
End Sub
'******************************************************************
' Appends var matrix M2 to M1 either vertically or horizontally
' AppendOption: AppendVertically or AppendHorizontally
' - error if matrix sizes don't match for an append operation
'   row sizes must be equal for horizontal append
'   column sizes must be equal for vertical append
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Function FQ_matrix_append_var(M1() As Variant, M2() As Variant, AppendOption As MatrixAlignment) As Variant()
Dim M() As Variant
Dim nrow1 As Long, ncol1 As Long, nrow2 As Long, ncol2 As Long
Dim i As Long, j As Long
' check if both matrices are empty
If FQ_ArrayDimension(M1) = 0 And FQ_ArrayDimension(M2) = 0 Then
    FQ_matrix_append_var = M
    Exit Function
End If
If FQ_ArrayDimension(M1) = 0 Then
    FQ_matrix_append_var = M2
    Exit Function
End If
' get matrix sizes
nrow1 = UBound(M1, 1)
ncol1 = UBound(M1, 2)
nrow2 = UBound(M2, 1)
ncol2 = UBound(M2, 2)

Select Case AppendOption
    Case nHorizontal
        If nrow1 <> nrow2 Then
            FQ_MessageBox ("Error in FQ_matrix_append: Row sizes of M1 and M2 must be equal for horizontal append!")
            Err.Raise (FQ_ErrorNum)
            Exit Function
        End If
        ReDim M(1 To nrow1, 1 To (ncol1 + ncol2))
        ' fill values of M1
        For i = 1 To nrow1
            For j = 1 To ncol1
                M(i, j) = M1(i, j)
            Next j
        Next i
        ' fill values of M2
        For i = 1 To nrow2
            For j = 1 To ncol2
                M(i, j + ncol1) = M2(i, j)
            Next j
        Next i
        
    Case nVertical
        If ncol1 <> ncol2 Then
            FQ_MessageBox ("Error in FQ_matrix_append: Column sizes of M1 and M2 must be equal for vertical append!")
            Err.Raise (FQ_ErrorNum)
            Exit Function
        End If
        ReDim M(1 To (nrow1 + nrow2), 1 To ncol1)
        ' fill values of M1
        For i = 1 To nrow1
            For j = 1 To ncol1
                M(i, j) = M1(i, j)
            Next j
        Next i
        ' fill values of M2
        For i = 1 To nrow2
            For j = 1 To ncol2
                M(i + nrow1, j) = M2(i, j)
            Next j
        Next i
        
    Case Else
        FQ_MessageBox ("Error in FQ_matrix_append: Invalid append option!")
        Err.Raise (FQ_ErrorNum)
        Exit Function
End Select
FQ_matrix_append_var = M
End Function
Sub DefineProceduresAndFunctionsForExcel()
Application.MacroOptions Macro:="FQS_generate_test_data", _
Description:="Generate test data by generating all possible combinations " _
 & "of given sets of attribute values."
 
Application.MacroOptions Macro:="FQS_generate_test_data_multiple_range", _
Description:="Generate test data by generating all possible combinations " _
 & "of given sets of attribute values. Entering multiple ranges of data sets is possible."
End Sub
'******************************************************************
' Calculates optimal coefficient vector Beta for given observation data
' X matrix (inputs X1 .. Xn) and Y vector (output)
' Assumes vectical input of data (i.e. column vectors X1, X2, .. Xn and Y)
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Sub FQS_curve_fitting()
Dim Xrange As Range, Yrange As Range, Brange As Range
Dim x() As Double, Xtr() As Double, Y() As Double, Bopt() As Double
Dim AllOnes() As Double, ResultRange As Range, N As Long

' get observed input data X from sheet
Set Xrange = Application.InputBox _
(Prompt:="Please select the range for observed input data X (X1 .. Xn)", _
Title:="Input matrix X", Default:=Selection.Address, Type:=8)

x = FQ_range_to_matrix(Xrange)

' get observed output data Y from sheet
Set Yrange = Application.InputBox _
(Prompt:="Please select the range for observed output data Y", _
Title:="Input vector Y", Default:=Selection.Address, Type:=8)

Y = FQ_range_to_matrix(Yrange)

' calculate optimal Beta coefficients

' create Nx1 vertical matrix with all ones
N = UBound(x, 1) ' number of rows in matrix X
AllOnes = FQ_matrix_create(StartValue:=1, Interval:=0, nrow:=N, _
            ncol:=1)

' append matrix X to AllOnes horizontally
Xtr = FQ_matrix_append(AllOnes, x, MatrixAlignment.nHorizontal)

' calculate Bopt
' Bopt = inv(Xtr' * Xtr) * Xtr' * Y   - (') means transpose
Bopt = FQ_matrix_multiplication(FQ_matrix_transpose(Xtr), Xtr)
Bopt = FQ_matrix_inverse(Bopt)
Bopt = FQ_matrix_multiplication(Bopt, FQ_matrix_transpose(Xtr))
Bopt = FQ_matrix_multiplication(Bopt, Y)

' get output range
Set ResultRange = Application.InputBox _
(Prompt:="Please select the upper-left corner of the worksheet range " & _
"where you want the have results for optimal Beta coefficients.", _
Title:="Bopt", Default:=Selection.Address, Type:=8)

' write results (Bopt) to output range
Call FQ_variant_to_range(Bopt, ResultRange)
End Sub
'******************************************************************
' Construct the complete hierarchy table by obtaining all possible
' combinations of attribute values, for given attribute value pairs
' from a hierarchy.
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Function FQ_attribute_pairs_to_combinations(AttributePairs As Variant, _
    CounterStop() As Double) As Variant()
Dim CounterState() As Double, TestDataRow() As Variant
Dim i As Long, CounterStopped As Boolean, AttribPairCount As Integer
Dim str As String, CombinationCount As Long, j As Long
Dim AllAttributePairsMatched As Boolean, l As Long
Dim TestData() As Variant

' On Error GoTo EH1
' get number of attribute pairs
AttribPairCount = UBound(CounterStop)

' initiate counter vector
ReDim CounterState(1 To AttribPairCount)
For i = 1 To AttribPairCount
    CounterState(i) = 1     ' initial state
Next i

'initiate vector for a row of test data
ReDim TestDataRow(1 To 1, 1 To AttribPairCount + 1)

' construct all valid attribute combinations
i = 1
While Not CounterStopped
    If i > 1 Then
        Call FQ_increment_multidigit_counter(CounterState, CounterStop, CounterStopped)
    End If
    i = i + 1

    ' check parent-child relationship for all attribute pairs
    AllAttributePairsMatched = True

    For j = 1 To AttribPairCount - 1
        If AttributePairs(CounterState(j), 2 * j) <> AttributePairs(CounterState(j + 1), 2 * j + 1) Then
            AllAttributePairsMatched = False
            Exit For
        End If
    Next j
    
    If AllAttributePairsMatched Then
        ' construct row of test data
        For j = 1 To AttribPairCount
            TestDataRow(1, j) = AttributePairs(CounterState(j), 2 * j - 1)
        Next j
        l = AttribPairCount
        TestDataRow(1, l + 1) = AttributePairs(CounterState(l), 2 * l)
        TestData = FQ_matrix_append_var(TestData, TestDataRow, nVertical)
    End If
Wend
FQ_attribute_pairs_to_combinations = TestData
Exit Function
' Error handling
EH1:
FQ_MessageBox ("Error in FQ_attribute_pairs_to_combinations: " & Err.Number & " - " & Err.Description)
Err.Raise (Err.Number)
End Function
'******************************************************************
' Construct the complete hierarchy table by reading attribute pair
' values from excel sheet. Insert the hiearchy table (test data)
' into the given range HierarchyRange in excel.
' makro, worksheet function
' Author: Finaquant Analytics Ltd. - www.finaquant.com
'******************************************************************
Sub FQS_generate_hierarchy_table()
Dim AttributeData As Variant, AttributeSets As Variant
Dim OrderedArr As Variant, Vctr() As Double, CounterLimits() As Double
Dim i As Long, j As Long, AttributeCombinations As Variant
Dim r1 As Range, x As Long
Dim AttributeDataRange As Range, OutputDataRange As Range

' On Error GoTo EH1
' get attribute data from user
Set AttributeDataRange = Application.InputBox _
(Prompt:="Please select the worksheet range where you define the attribute value pairs of a hierarchy.", _
Title:="Attribute sets", Default:=Selection.Address, Type:=8)

' get output range
Set OutputDataRange = Application.InputBox _
(Prompt:="Please select the upper-left corner of the worksheet range " & _
"where you want the have the test data as complete hierarchy table.", _
Title:="Attribute sets", Default:=Selection.Address, Type:=8)

' read range with attribute values
AttributeData = FQ_range_to_variant(AttributeDataRange)

' Shift all non-empty cells upwards so that there are no empty
' cells between non-empty ones.
Call FQ_order_nonempty_elements(AttributeData, AttributeSets, Vctr)

' check vector sizes of attribute value pairs
If UBound(Vctr) Mod 2 <> 0 Then
    FQ_MessageBox ("Attribute pair data range must contain an even number of columns!")
    Err.Raise (FQ_ErrorNum)
End If
For i = 1 To UBound(Vctr) / 2
    If Vctr(2 * i) <> Vctr(2 * i - 1) Then
        FQ_MessageBox ("Vector size mismatch: The vector size of attribute value pairs must be identical!")
        Err.Raise (FQ_ErrorNum)
    End If
Next i

' initiate and set counter limits
x = UBound(Vctr) / 2
ReDim CounterLimits(1 To x)
For i = 1 To x
    CounterLimits(i) = Vctr(2 * i)
Next i

' TEST
Debug.Print "Vctr = " & Chr(10) & FQ_vector_format(Vctr)
Debug.Print "CounterLimits = " & Chr(10) & FQ_vector_format(CounterLimits)

' get all possible combinations of attribute values
AttributeCombinations = FQ_attribute_pairs_to_combinations(AttributeSets, CounterLimits)

' write attribute combinations into worksheet range
Call FQ_variant_to_range(AttributeCombinations, OutputDataRange)
Exit Sub
' Error handling
EH1:
FQ_MessageBox ("Error in FQS_generate_hierarchy_table: " & Err.Number & " - " & Err.Description)
Err.Raise (Err.Number)
End Sub
